home *** CD-ROM | disk | FTP | other *** search
/ Shareware Gold 2 / Shareware Gold II - Volume 2 Number 1 - Wayzata Technology (7071) (1991).iso / database / pds_base / utilprog.exe / lha / DB-BLANK.SRC < prev    next >
Text File  |  1990-03-10  |  9KB  |  132 lines
  1. |2010 PASSWORD$="|36":BLINKNORMAL%=|28:BLINKINSERT%=|29:BLINK2%=|30 'For CGA or EGA adapter, BLINKNORMAL%=6, BLINKINSERT%=4 and BLINK2%=7. For Monochrome adapter, BLINKNORMAL%=13, BLINKINSERT%=9 and BLINK2%=14.
  2. |2020 LOCATE 1,10:COLOR COLA%(2),COLB%(1):PRINT "Program |01 To Create The Blank |11 Data Base Files";:COLOR 7,0:PASSCOUNT%=0
  3. 2030 LOCATE 3,18,0:COLOR COLA%(2),0:PRINT "Enter the required Password ? ";:COLOR 7,0:FLDPOSVERT%=CSRLIN:FLDPOSHORIZ%=POS(0)
  4. 2040 GOSUB 5000:PASS$=F$:PASSCOUNT%=PASSCOUNT%+1:PASSOK%=1:FOR J=1 TO 10:IF ASC(MID$(PASS$,J,1))+127 <> ASC(MID$(PASSWORD$,J,1)) THEN PASSOK%=0
  5. 2050 NEXT:IF PASSOK%=0 THEN IF PASSCOUNT%=3 THEN GOTO 460 ELSE BEEP:LOCATE 24,25,0:COLOR 15,0:PRINT "Incorrect Password - Try Again";:COLOR 7,0:GOTO 2040
  6. 2060 LOCATE 24,1,0:PRINT SPC(79):FLOPPY%=0:FOR J=1 TO ZQ:FOR K=1 TO ZS%(J,5):IF ZT%(J,K,3) < 3 THEN FLOPPY%=1
  7. 2070 NEXT:NEXT:IF FLOPPY%=1 THEN LOCATE 5,5,0:COLOR COLA%(3),0:PRINT "Insert the floppy disk(s) in drive(s) listed in the Definition Listing";
  8. 2080 LOCATE 7,14,0:COLOR COLA%(4)+16,0:PRINT "WARNING!!! - Existing Data Files Will Be Wiped Out!";:COLOR 7,0
  9. 2090 LOCATE 9,26,0:COLOR COLA%(2),0:PRINT "Do you wish to continue ? ";:COLOR 0,COLA%(3):PRINT "N";:LOCATE ,POS(0)-1,1:A$="":WHILE A$="":A$=INKEY$:WEND:IF ASC(A$)=13 THEN A$="N"
  10. 2100 PRINT A$;:COLOR 7,0:IF A$<>"Y" AND A$<>"y" THEN GOTO 460
  11. 2110 DETAIL = 0:MASTER = 0:IF ZQ =1 THEN ZEND = 1:ZEND=1:GOTO 2180
  12. 2120 CLS:PRINT "Data Files for the ";ZB$;" Data Base":PRINT:FOR J = 1 TO ZQ:PRINT J;" - ";ZS$(J,1):PRINT:NEXT:PRINT:INPUT "Enter file number to Blank (A=All)";ANS$
  13. 2130 IF ANS$ = "A" OR ANS$ = "a" THEN ZSTART = 1:ZEND=ZQ:GOTO 2180 ELSE ZSTART = VAL(ANS$):ZEND = ZSTART:GOTO 2150
  14. 2140 IF VAL(ANS$) = 0 OR VAL(ANS$) > ZQ THEN GOTO 460 'Pressed Enter, zero or too large a number
  15. 2150 IF ZS%(ZSTART,1) = 1 THEN GOTO 2180 ELSE FOR J=1 TO ZQ:IF ZS$(J,1) = ZS$(ZSTART,2) THEN MASTER = J:J=ZQ
  16. 2160 NEXT:FOR J=2 TO ZS%(MASTER,4)+1:IF ZS$(ZSTART,1) = ZS$(MASTER,J) THEN DETAIL = J-1:J=ZS%(MASTER,4)+1
  17. 2170 NEXT
  18. 2180 DT$=LEFT$(DATE$,2)+MID$(DATE$,4,2)+LEFT$(DATE$,1):TM$=LEFT$(TIME$,5):ZERO=0 'Date and Time 
  19. 2190 FOR FILENUM% = ZSTART TO ZEND 'Loop for each data file in the Data Base
  20. 2200 FORWARDPOINTER% = 1
  21. 2210 FOR K = 1 TO ZS%(FILENUM%,5) 'Number of file sections for each data file
  22. 2220 F$=CHR$(64+ZT%(FILENUM%,K,3))+":"+ZS$(FILENUM%,1) 'Drive Letter+:+File Name
  23. 2230 LOCATE 12,17,1 : PRINT "Creating The '";F$;"' FILE.    " ;:LOCATE 14,17,0:PRINT "Record";:PRINT SPC(25);
  24. 2240 OPEN F$ AS #1 LEN=ZS%(FILENUM%,3)
  25. 2250 C1=0
  26. 2260 IF ZS%(FILENUM%,1)=2 THEN FIELD #1, 5 AS ZB$, 5 AS ZF$:RSET ZB$=STR$(0):RSET ZF$=STR$(0):C1=10:GOTO 2320 'Detail File
  27. 2270 FIELD #1, 5 AS ZC$, 5 AS ZP$, 5 AS ZN$:C1=15
  28. 2280 IF ZS%(FILENUM%,4) = 0 GOTO 2320
  29. 2290 FOR L = 1 TO ZS%(FILENUM%,4)
  30. 2300 FIELD #1, C1 AS DUMMY$, 5 AS ZH$(FILENUM%,L), 5 AS ZE$(FILENUM%,L):C1=C1+10:RSET ZH$(FILENUM%,L)=STR$(0):RSET ZE$(FILENUM%,L)=STR$(0)
  31. 2310 NEXT 'L
  32. 2320 C2=0:C3=0:C4=0
  33. 2330 FOR L=1 TO ZS%(FILENUM%,7) 'Number of fields in the file
  34. 2340 Y=ZSIZE%(FILENUM%,L) 'Length of each field
  35. 2350 FIELD #1, C1 AS DUMMY1$, C2 AS DUMMY2$, C3 AS DUMMY3$, C4 AS DUMMY$, Y AS Y$(L,FILENUM%):LSET Y$(L,FILENUM%)=STRING$(Y,32)
  36. 2360 IF C1+Y<256 THEN C1=C1+Y ELSE IF C2+Y<256 THEN C2=C2+Y ELSE IF C3+Y<256 THEN C3=C3+Y ELSE C4=C4+Y
  37. 2370 NEXT 'L
  38. 2380 IF ZS%(FILENUM%,1)=1 THEN RSET ZC$=STR$(0):RSET ZP$=STR$(0):RSET ZN$=STR$(0):FOR L=1 TO ZS%(FILENUM%,4):RSET ZH$(FILENUM%,L)=STR$(0):RSET ZE$(FILENUM%,L)=STR$(0):NEXT 'L
  39. 2390 ' House keeping fields
  40. 2400 FIELD #1, 5 AS HOUSE1$, 5 AS HOUSE2$, 5 AS HOUSE3$
  41. 2410 M = ZT%(FILENUM%,K,2) - ZT%(FILENUM%,K,1) + 1
  42. 2420 FOR L = 1 TO M
  43. 2430 IF ZS%(FILENUM%,1)=2 THEN FORWARDPOINTER%=FORWARDPOINTER%+1:RSET ZF$=STR$(FORWARDPOINTER%)
  44. 2440 PUT #1,L
  45. 2450 LOCATE 14,24,0:PRINT L;
  46. 2460 NEXT 'L
  47. 2470 IF K <> ZS%(FILENUM%,5) GOTO 2520
  48. 2480 'PUT the housekeeping record
  49. 2490 IF ZS%(FILENUM%,1)=1 THEN RSET HOUSE1$=STR$(0):LSET HOUSE2$=DT$:LSET HOUSE3$=TM$
  50. 2500 IF ZS%(FILENUM%,1)=2 THEN RSET HOUSE1$=STR$(0):RSET HOUSE2$=STR$(1):RSET HOUSE3$=STR$(0)
  51. 2510 M=M+1:PUT #1,M
  52. 2520 CLOSE
  53. 2530 NEXT 'K Done with this file section
  54. 2540 NEXT 'FILENUM% Done with this file
  55. 2545 IF MASTER > 0 THEN GOSUB 7000
  56. 2550 GOTO 460
  57. 5000 'Subroutine to input Password
  58. 5040    EFLAG%=1:ESCFLAG%=0:CFLAG%=0:ZENDSAVE%=0:INSERT%=0
  59. 5050    WHILE EFLAG%=1 'loop on this field until EFLAG% set to zero
  60. 5060       F$=STRING$(10,32):LOCATE FLDPOSVERT%,FLDPOSHORIZ%,0:COLOR 0,COLA%(3):PRINT F$:COLOR 7,0:LOCATE FLDPOSVERT%,FLDPOSHORIZ%,1:Z2=10
  61. 5070       FOR ZJ=1 TO Z2
  62. 5080          YC$="":WHILE YC$="":YC$=INKEY$:WEND:POSX%=CSRLIN:POSY%=POS(0) 'strobe keyboard for next character
  63. 5090          IF CFLAG%=1 THEN LOCATE 25,1,0:PRINT SPC(79):LOCATE POSX%,POSY%,1:CFLAG%=0
  64. 5100          IF LEN(YC$)=2 THEN YC%=ASC(RIGHT$(YC$,1)):GOSUB 5600:GOTO 5190
  65. 5110          YC%=ASC(YC$)
  66. 5120          IF YC%=27 THEN ZJ=Z2:ESCFLAG%=1:GOTO 5190
  67. 5130          IF YC%=8 THEN GOSUB 5500:GOTO 5080
  68. 5140          IF YC%=13 THEN ZJ=Z2:GOTO 5190
  69. 5150          POSY%=POS(0):GOSUB 5800:IF CFLAG%=1 THEN LOCATE POSX%,POSY%,1:GOTO 5080
  70. 5160          IF INSERT%=1 THEN GOSUB 6200 
  71. 5170          COLOR 0,COLA%(3):PRINT YC$;:COLOR 7,0:MID$(F$,ZJ,1)=YC$
  72. 5190       NEXT 'ZJ
  73. 5200       LOCATE ,,,BLINKNORMAL%,BLINK2%:INSERT%=0:IF ZI=1 THEN IF YC%=13 AND F$=STRING$(Z2,32) THEN RETURN 'finished
  74. 5210       IF ESCFLAG%=1 THEN RETURN 'abort from this record
  75. 5220       EFLAG%=0
  76. 5250    WEND 'EFLAG%
  77. 5330 RETURN
  78. 5500 'Subroutine for backspace
  79. 5520 IF ZJ=1 THEN RETURN
  80. 5530 IF FLDTYPE%=4 AND EFLAG%=0 THEN IF ZJ=3 OR ZJ=7 THEN LOCATE ,POS(0)-2:ZJ=ZJ-2:RETURN 'skip spaces on Date field
  81. 5540 LOCATE ,POS(0)-1,1:COLOR 0,COLA%(3):PRINT " ";:COLOR 7,0:LOCATE ,POS(0)-1,1:MID$(F$,ZJ-1,1)=" ":ZJ=ZJ-1
  82. 5550 RETURN
  83. 5600 'Extended code key pressed
  84. 5640 IF YC%=75 THEN ZJ=ZJ-1:IF ZJ>0 THEN ZJ=ZJ-1:LOCATE ,POS(0)-1:RETURN 'left arrow
  85. 5650 IF YC%=77 AND ZJ<Z2 THEN LOCATE ,POS(0)+1:RETURN 'right arrow
  86. 5710 IF YC%=82 THEN ZJ=ZJ-1:IF INSERT%=0 AND ZJ<Z2 THEN INSERT%=1:LOCATE ,,,BLINKINSERT%,BLINK2%:RETURN ELSE INSERT%=0:LOCATE ,,,BLINKNORMAL%,BLINK2%:RETURN ' insert key
  87. 5720 IF YC%=83 THEN IF ZJ<Z2 THEN FLD$=MID$(F$,ZJ+1)+" " ELSE FLD$=" " 'delete key
  88. 5730 IF YC%=83 THEN COLOR 0,COLA%(3):LOCATE ,,0:PRINT FLD$:COLOR 7,0:LOCATE FLDPOSVERT%,POSY%,1:MID$(F$,ZJ)=FLD$:ZJ=ZJ-1:RETURN 'delete key
  89. 5740 SOUND 400,1:RETURN 'key not used
  90. 5800 'Character type field
  91. 5810 IF YC%>96 AND YC%<123 THEN YC%=YC%-32:YC$=CHR$(YC%):RETURN ELSE IF YC%>44 OR YC%<91 THEN RETURN
  92. 5820 SOUND 400,1:CFLAG%=1
  93. 5830 LOCATE 25,31,0:COLOR 15,0:PRINT "Illegal key stroke";:COLOR 7,0
  94. 5840 RETURN
  95. 6200 'Handle Inserted Character
  96. 6210 IF ZJ=Z2 THEN RETURN 'no insert if at end of field
  97. 6220 FLD$=MID$(F$,ZJ,Z2-ZJ)
  98. 6230 MID$(F$,ZJ+1,Z2-ZJ-1)=FLD$:COLOR 0,COLA%(3):LOCATE ,POSY%+1,0:PRINT FLD$;:COLOR 7,0:LOCATE ,POSY%,1
  99. 6240 RETURN
  100. 7000 'SUBROUTINE to set Chain Head and Chain End pointers to zero for Master file where an associated detail file was blanked
  101. 7010 FOR K = 1 TO ZS%(MASTER,5) 'Number of file sections for each data file
  102. 7020 F$=CHR$(64+ZT%(MASTER,K,3))+":"+ZS$(MASTER,1) 'Drive Letter+:+File Name
  103. 7030 LOCATE 12,17,1 : PRINT "Updating pointers in the '";F$;"' FILE.    " ;:LOCATE 14,17,0:PRINT "Record";:PRINT SPC(25);
  104. 7040 OPEN F$ AS #1 LEN=ZS%(MASTER,3)
  105. 7050 C1=0
  106. 7070 FIELD #1, 5 AS ZC$, 5 AS ZP$, 5 AS ZN$:C1=15
  107. 7090 FOR L = 1 TO ZS%(MASTER,4) 'Detail Chain Head and Chain End pointers
  108. 7100 FIELD #1, C1 AS DUMMY$, 5 AS ZH$(MASTER,L), 5 AS ZE$(MASTER,L):C1=C1+10:LSET ZH$(MASTER,L)=STR$(0):LSET ZE$(MASTER,L)=STR$(0)
  109. 7110 NEXT 'L
  110. 7120 C2=0:C3=0:C4=0
  111. 7130 FOR L=1 TO ZS%(MASTER,7) 'Number of fields in the file
  112. 7140 Y=ZSIZE%(MASTER,L) 'Length of each field
  113. 7150 FIELD #1, C1 AS DUMMY1$, C2 AS DUMMY2$, C3 AS DUMMY3$, C4 AS DUMMY$, Y AS Y$(L,MASTER):LSET Y$(L,MASTER)=STRING$(Y,32)
  114. 7160 IF C1+Y<256 THEN C1=C1+Y ELSE IF C2+Y<256 THEN C2=C2+Y ELSE IF C3+Y<256 THEN C3=C3+Y ELSE C4=C4+Y
  115. 7170 NEXT 'L
  116. 7190 ' House keeping fields
  117. 7200 FIELD #1, 5 AS HOUSE1$, 5 AS HOUSE2$, 5 AS HOUSE3$
  118. 7210 M = ZT%(MASTER,K,2) - ZT%(MASTER,K,1) + 1
  119. 7220 FOR L = 1 TO M
  120. 7230 GET #1,L:RSET ZH$(MASTER,DETAIL) = STR$(0):RSET ZE$(MASTER,DETAIL) = STR$(0) 'GET the record and zero out just the Chain Head and End pointers for the proper Detail file
  121. 7240 PUT #1,L
  122. 7250 LOCATE 14,24,0:PRINT L;
  123. 7260 NEXT 'L
  124. 7270 IF K <> ZS%(MASTER,5) GOTO 7320
  125. 7280 'PUT the housekeeping record
  126. 7290 LSET HOUSE2$=DT$:LSET HOUSE3$=TM$
  127. 7310 M=M+1:PUT #1,M
  128. 7320 CLOSE
  129. 7330 NEXT 'K Done with this file section
  130. 7340 RETURN
  131. *31 Copyright 1987 by PRO DEV Software
  132.